
Dim op1, op2, op3, op4, opcode, message As String
Dim hexbyte As Long
Dim op(22)
Dim v As Long
Dim portno As String
Dim high_byte, low_byte As Byte 'data bytes from comm port
Dim valid_byte As Boolean   'data from comm port is valid

Dim mypath, drive, folder As String
Dim mainfile, outfile, hexdatafile, incfile, filename, header As String
Dim progline As String
Dim hexdata(8), memdata(8192), romdata(512), labels, labelvalue(500), variables(500), variablevalue(500), ops_lit, ops_bit, ops_byte, ops_cont, ops_inherent, ops_c_comp
Dim byte_val, bit_val, lit_val, cont_val, inherent_val, c_comp_val
Dim bytecount, romloc, romcount, ramloc, d, N, mm As Byte
Dim fileloaded, headerfile, finished, anyerrors, goodinst, valid  As Boolean
Dim all_labels(500), newlabel, hexline As String
Dim pass, csum, varicounter, labelcounter, config, config1, config2 As Long

Dim basecode, address As Long
Const mainfilenum = 1
Const incfilenum = 2
Const outfilenum = 3
Const hexdatafilenum = 4
Const configfilenum = 6
Dim epdata(512), memata(8192), deviceid(4), bitvalue As Long
Dim pickfile, stripfile As String
Const cmdloadconfig = &H0
Const cmdloaddatamem = &H2
Const cmdreaddatamem = &H4
Const cmdincaddress = &H6
Const cmdbegineraseprog = &H8
Const cmdbeginprogonly = &H24
Const cmdloaddataeprom = &H3
Const cmdreaddataeprom = &H5
Const cmdbulkeraseprog = &H9
Const cmdbulkeraseeprom = &HB
Const setup1 = &H1
Const setup2 = &H7
Dim osc(15) As devicedata
Dim cfg(15) As devicedata
Dim device As String
Dim oscselected As String
Dim oscmask As Long

Private Sub Check1_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(1).valueon Xor cfg(1).valueoff
mask = &H3FFF Xor bv
If Check1.Value = 1 Then
    If cfg(1).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check1.Value = 0 Then
    If cfg(1).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Check10_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(10).valueon Xor cfg(10).valueoff
mask = &H3FFF Xor bv
If Check10.Value = 1 Then
    If cfg(10).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check10.Value = 0 Then
    If cfg(10).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Check2_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(2).valueon Xor cfg(2).valueoff
mask = &H3FFF Xor bv
If Check2.Value = 1 Then
    If cfg(2).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check2.Value = 0 Then
    If cfg(2).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub check3_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(3).valueon Xor cfg(3).valueoff
mask = &H3FFF Xor bv
If Check3.Value = 1 Then
    If cfg(3).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check3.Value = 0 Then
    If cfg(3).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub check4_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(4).valueon Xor cfg(4).valueoff
mask = &H3FFF Xor bv
If Check4.Value = 1 Then
    If cfg(4).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check4.Value = 0 Then
    If cfg(4).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Check5_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(5).valueon Xor cfg(5).valueoff
mask = &H3FFF Xor bv
If Check5.Value = 1 Then
    If cfg(5).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check5.Value = 0 Then
    If cfg(5).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Check6_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(6).valueon Xor cfg(6).valueoff
mask = &H3FFF Xor bv
If Check6.Value = 1 Then
    If cfg(6).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check6.Value = 0 Then
    If cfg(6).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Check7_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(7).valueon Xor cfg(7).valueoff
mask = &H3FFF Xor bv
If Check7.Value = 1 Then
    If cfg(7).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check7.Value = 0 Then
    If cfg(7).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Check8_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(8).valueon Xor cfg(8).valueoff
mask = &H3FFF Xor bv
If Check8.Value = 1 Then
    If cfg(8).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check8.Value = 0 Then
    If cfg(8).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Check9_Click()
Dim bv, mask As Long
configword = swap(configword)
bv = cfg(9).valueon Xor cfg(9).valueoff
mask = &H3FFF Xor bv
If Check9.Value = 1 Then
    If cfg(9).valueon = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
If Check9.Value = 0 Then
    If cfg(9).valueoff = &H3FFF Then
        configword = (configword Or bv) And &H3FFF
    Else
        configword = (configword And mask) And &H3FFF
    End If
End If
configword = swap(configword)
Text4.Text = heks(swap(configword))

End Sub

Private Sub Combo1_click()
Dim X, bv, mask, cfw As Long
cfw = swap(configword)
For X = 1 To 14
    If osc(X).name = Combo1.Text Then Exit For
Next X
cfw = (cfw Or oscmask) And osc(X).valueon
configword = swap(cfw)
calcconfig
End Sub

Private Sub Combo2_click()
Text3.Text = ""
configword = &HFF3F
Combo1.Clear
On Error GoTo procerror
Close #(configfilenum)
op2 = Combo2.Text
setfunction (2)
calcconfig
procerror:
End Sub

Private Sub Command1_Click()
Form2.Text8.Text = ""
Form2.Show
Form1.Hide
End Sub

Private Sub Command10_Click()
'Dim result As Long
'result = MsgBox("Are You Sure? ", vbOKCancel)
MSComm1.CommPort = Text1.Text
MSComm1.portopen = True
erasepic
MSComm1.portopen = False

End Sub

Private Sub Command2_Click()
Open App.Path + "\" + "picasm.cfg" For Output As #(configfilenum)
Print #(configfilenum), mypath 'File1.Path
If filename = "" Then filename = "No File Selected"
Print #(configfilenum), filename
Print #(configfilenum), Combo2.Text
Close #(configfilenum)
Close #1
Close #2
Close #3
Close #4
Close #5
Close #6
CommClose (COMmNum)
Unload Form3
Unload Form2
Unload Me
End Sub

Private Sub Command3_Click()

Cls

End Sub

Private Sub Command4_Click()
Cls
Check1.Visible = False
Check2.Visible = False
Check3.Visible = False
Check4.Visible = False
Check5.Visible = False
Check6.Visible = False
Check7.Visible = False
Check8.Visible = False
Combo1.Clear
Close #1
Close #2
Close #3
Close #4
Close #5
Close #6

assemble
readhexfile
calcconfig
Combo2.Text = device
Text4.Text = heks(swap(configword))

End Sub
Private Sub progchip()
'//Programme pic
Dim X, Y, z, block As Long

If LCase(Right(pickfile, 4)) = ".hex" Then fileloaded = True
If Not fileloaded Then GoTo fail
ProgressBar1.Min = 0
ProgressBar1.Value = 0
ProgressBar1.Max = himem + 6
Frame1.Visible = True
 setprogmode
  If Not fileloaded Then
  Exit Sub
 End If
 Cls
 Print "Programming Pic with file ", filename
 
 setprogmode
 Print "Erasing Device"
 erasepic
 Print "Writing programme"
 If mode = 1 Then
setprogmode
  For X = 0 To himem
   If memdata(X) = &HFF3F Then
    outcommand (cmdincaddress)
    Else
        outcommand (&H2)    ';{CmdLoadDataMem);}
        outdata (memdata(X))
        outcommand (8)    ';{CmdBeginEraseProg);}
       
        delay (8)
        outcommand (cmdincaddress)
  End If
  ProgressBar1.Value = X
 Next X
 End If
 z = 0
 If mode = 2 Then
  setprogmode
  outcommand (&H1F)
  setprogmode
  X = 0
Do While X <= himem
   block = &HFF3F
   For Y = 1 To 3
   If memdata(X) <> &HFF3F Then
    
       outcommand (2)  ';{load data for prog mem}
       outdata (memdata(X))
   End If
     block = (block And memdata(X))
    
     outcommand (6)    ';{increment address}
     X = X + 1
   Next Y
   If memdata(X) <> &HFF3F Then
  
    outcommand (2)   ';{load data for prog mem}
    outdata (memdata(X))
   End If
   block = (block And memdata(X))
   X = X + 1
   If block <> &HFF3F Then
    outcommand (&H18)
    outcommand (&H17)   ';{end programming}
   End If
   outcommand (6)  ';{increment address}
   ProgressBar1.Value = X
  Loop
 End If
 ProgressBar1.Min = 0
 ProgressBar1.Value = 0
ProgressBar1.Max = maxrom + 2

 Print "Programming EEprom Data"
 setprogmode
 For X = 0 To maxrom
 
   outcommand (cmdloaddataeprom)
   outdata (epdata(X))
   If mode = 2 Then
    
     outcommand (&H18)
     outcommand (&H17)
     Else
    
     outcommand (cmdbegineraseprog)
   End If
  
   outcommand (cmdincaddress)
   ProgressBar1.Value = X
 Next X
 Print "Programming Configuration Memory"
 setprogmode

 outcommand (cmdloadconfig)
 outdata (configword)
 For X = 1 To 7
  
   outcommand (cmdincaddress)
 Next X

 outcommand (cmdloaddatamem)
 outdata (configword)
 If mode = 2 Then
  
   outcommand (&H18) ';{prog only}
   outcommand (&H17) ';{end prog}
   outcommand (&H6)  ';{inc addr}
   outcommand (&H2) ';{load data}
   outdata (&HFF3F)
   outcommand (&H18) ';{prog only}
   outcommand (&H17) ';{end prog}
 Else
    outcommand (cmdbegineraseprog)
    delay 10
 End If

 message = ("")
 Print "Verifying Programme Memory"
 setprogmode
 ProgressBar1.Min = 0
 ProgressBar1.Value = 0
 ProgressBar1.Max = himem + 4

 For X = 0 To himem
  If memdata(X) <> &HFF3F Then
    While MSComm1.CTSHolding = False
    Wend
 
     outcommand (cmdreaddatamem)
     If memdata(X) <> indata Then
      message = "Programme memory fail"
        GoTo fail
     End If
  End If
 
   outcommand (cmdincaddress)
    ProgressBar1.Value = X
 Next X
  ProgressBar1.Min = 0
  ProgressBar1.Value = 0
 ProgressBar1.Max = maxrom + 2
 Print "Verifying Data Memory"
 setprogmode
 For X = 0 To maxrom
   
     outcommand (cmdreaddataeprom)
     If (epdata(X)) And &HFF <> (indata) And &HFF Then
       message = "EEprom data fail"
       GoTo fail
     End If
    
     outcommand (cmdincaddress)
 ProgressBar1.Value = X

Next X
 setprogmode
 outcommand (cmdloadconfig): outdata (0)
 For X = 1 To 7
    outcommand (cmdincaddress)
 Next X
 
   outcommand (cmdreaddatamem)
   z = swap(indata)
   Print "Config word sent to pic " + Hex(swap(configword)), ' ')
   Print
   Print "Config word read " + Hex(z)
  
fail:
  If message <> "" Then Print (message)
  message = ""

End Sub




Private Sub setfunction(name_check)
On Error GoTo procerror
Dim X, z As Integer
Dim st As String

Check1.Visible = False
Check2.Visible = False
Check3.Visible = False
Check4.Visible = False
Check5.Visible = False
Check6.Visible = False
Check7.Visible = False
Check8.Visible = False
Check9.Visible = False
Check10.Visible = False

  For z = 1 To 15
    cfg(z).name = ""
    cfg(z).valueon = &H3FFF
    cfg(z).valueoff = &H3FFF
    osc(z).name = ""
    osc(z).valueon = &H3FFF
  Next z
  If Left((op2), 2) = "p=" Then op2 = Mid(op2, 3, Len(op2))
  configfile = App.Path + "\datafiles\" + (op2) + ".dev"
  Open configfile For Input As #(configfilenum)
  Input #(configfilenum), device
  Input #(configfilenum), maxrom
  Form2.Text2.Text = maxrom
  Input #(configfilenum), maxram
  Form2.Text3 = maxram
  Input #(configfilenum), ramstart
  Form2.Text4.Text = ramstart
  Input #(configfilenum), himem
  Form2.Text1.Text = himem
  Input #(configfilenum), mode
  Form2.Text6.Text = mode
  Input #(configfilenum), oscmask

  st = "": op1 = ""
  While op1 <> "%"
    Input #(configfilenum), st
    parse (st)
  Wend
  X = 1: op1 = ""
  While op1 <> "no%"
   Line Input #(configfilenum), st: parse (st)
    If (op1 <> "") And (op1 <> "no%") Then
    Select Case X
    Case 1
        cfg(X).name = op1
        Check1.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        formbyte (LCase(op4))
        cfg(X).bitmask = hexbyte
        Check1.Visible = True
    Case 2
         cfg(X).name = op1
        Check2.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check2.Visible = True
     Case 3
        cfg(X).name = op1
        Check3.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check3.Visible = True
     Case 4
        cfg(X).name = op1
        Check4.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check4.Visible = True
     Case 5
        cfg(X).name = op1
        Check5.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check5.Visible = True
     Case 6
        cfg(X).name = op1
        Check6.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check6.Visible = True
    Case 7
        cfg(X).name = op1
        Check7.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check7.Visible = True
    Case 8
        cfg(X).name = op1
        Check8.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check8.Visible = True
        
     Case 9
        cfg(X).name = op1
        Check9.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check9.Visible = True
        
    Case 10
        cfg(X).name = op1
        Check10.Caption = op1
        formbyte (LCase(op2))
        cfg(X).valueon = hexbyte
        formbyte (LCase(op3))
        cfg(X).valueoff = hexbyte
        Check10.Visible = True
       
        
    End Select
     X = X + 1
    End If
  Wend
  
  While op1 <> "%"
  Line Input #(configfilenum), st
    parse (st)
  Wend
  X = 1: op1 = ""
  While op1 <> "no%"
  Line Input #(configfilenum), st: parse (st)
    If (op1 <> "") And (op1 <> "no%") Then
    
    Select Case X
    
    Case 1
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
    formbyte LCase(op3)
 '   osc(X).valueoff = &H3FFF 'hexbyte
    Combo1.AddItem (op1)
    
    Case 2
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
'    formbyte LCase(op3)
    osc(X).valueoff = &H3FFF
    Combo1.AddItem (op1)
    
    Case 3
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
'    formbyte LCase(op3)
    osc(X).valueoff = &H3FFF
    Combo1.AddItem (op1)
    
    Case 4
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
'    formbyte LCase(op3)
    osc(X).valueoff = &H3FFF
    Combo1.AddItem (op1)
    
    Case 5
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
'    formbyte LCase(op3)
    osc(X).valueoff = &H3FFF
    Combo1.AddItem (op1)
    
    Case 6
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
'    formbyte LCase(op3)
    osc(X).valueoff = &H3FFF
    Combo1.AddItem (op1)
    
    Case 7
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
'    formbyte LCase(op3)
    osc(X).valueoff = &H3FFF
    Combo1.AddItem op1
    
    Case 8
    formbyte (LCase(op2))
    osc(X).name = op1
    osc(X).valueon = hexbyte
'    formbyte LCase(op3)
    osc(X).valueoff = &H3FFF
    Combo1.AddItem op1
    
    End Select
    Combo1.Visible = True
     X = X + 1
    End If
  Wend
  goodinst = True
  Close #(configfilenum)
Exit Sub
procerror:
answer = MsgBox("Set function aborted", 0, "")
End Sub

Private Sub setconfig()
Dim X As Integer

config1 = &H3FFF
config2 = &H3FFF
config = &H3FFF
For X = 2 To 12
    If (op(X) <> "") And (Left(op(2), 7) <> "_config") And (op(X) <> "&") Then
        checkvar (op(X))
        If valid Then config = config And hexbyte
        If Not valid Then message = "Not a valid Config setting"
    End If
Next X
End Sub

Private Sub Command5_Click()
If LCase(Right(Text3.Text, 4)) <> ".hex" Then GoTo nothex
MSComm1.CommPort = Text1.Text
MSComm1.portopen = True
progchip
vppoff
MSComm1.portopen = False
Frame1.Visible = False
Exit Sub
nothex:
answer = MsgBox("Not a HEX file", vbExclamation)
Exit Sub
porterror:
answer = MsgBox("Invalid Port", 0, "")
End Sub

Private Sub Command6_Click()
calcconfig
End Sub

Private Sub Command7_Click()
MSComm1.CommPort = Text1.Text
MSComm1.portopen = True


progconfig
MSComm1.portopen = False
End Sub

Private Sub Command9_Click()    'load hex file
Dim X, Y As Long
Check1.Visible = False
Check2.Visible = False
Check3.Visible = False
Check4.Visible = False
Check5.Visible = False
Check6.Visible = False
Check7.Visible = False
Check8.Visible = False
Check9.Visible = False
Check10.Visible = False
Text3.Text = "No File Loaded"

op2 = Combo2.Text
op2 = RTrim(op2)
setfunction (1)
hexdatafile = mypath + stripfile + ".hex"
Text3.Text = pickfile
readhexfile
calcconfig

Text4.Text = heks(swap(configword))
End Sub

Private Sub Dir1_Change()
file1.Path = Dir1.Path

End Sub

Private Sub Drive1_change()
On Error GoTo procerror
Dir1.Path = Left(Drive1.drive, 1) + ":\"
mypath = Dir1.Path
Exit Sub
procerror:
answer = MsgBox("Drive not available", 48, " ")
End Sub


Private Sub File1_click()
Dim X As Long
Dim st As String
file1.Path = Dir1.Path
mypath = file1.Path
If Right(mypath, 1) <> "\" Then mypath = mypath + "\"
pickfile = file1.filename
If InStr(pickfile, ".") > 0 Then
    stripfile = Left(pickfile, (InStr(pickfile, ".") - 1))
End If
If LCase(Right(pickfile, 4)) = ".asm" Then
Text2.Text = pickfile
Else: Text2.Text = "No File Selected"
End If
filename = file1.filename
If Option3.Value = True Then
 filename = mypath + file1.filename
 Form3.Text1.Text = ""
  Open filename For Input As #7
  Do While Not EOF(7)
    Line Input #7, st
    Form3.Text1.Text = Form3.Text1.Text + vbCrLf + st
  Loop
  Close #7
  Form3.Show
End If
End Sub

Public Sub Form_Load()
On Error GoTo procerror
Dim result, answer As Long
Dim temp As String

Frame1.Visible = False

Open App.Path + "\" + "picasm.cfg" For Input As configfilenum
Line Input #(configfilenum), mypath 'temp
filename = "No File Selected"
Line Input #(configfilenum), temp
Line Input #(configfilenum), device

Close #(configfilenum)
Combo2.Text = device
Dir1.Path = mypath
GoTo noerror
procerror:
mypath = App.Path
noerror:
On Error GoTo porterror:


Check1.Visible = False
Check2.Visible = False
Check3.Visible = False
Check4.Visible = False
Check5.Visible = False
Check6.Visible = False
Check7.Visible = False
Check8.Visible = False
Check9.Visible = False
Check10.Visible = False

Combo1.Clear
Combo1.Visible = False

Option1.Value = True
op2 = Combo2.Text
setfunction (op2)
calcconfig
'procexit:
Exit Sub
porterror:
answer = MsgBox("cant open port", vbExclamation)

End Sub




Private Sub parse(asmline As String)
Dim X, Y, z, stringsize As Integer
goodinst = False
For X = 0 To 22
    op(X) = ""
Next X
stringsize = Len(asmline)
op1 = "": op2 = "": op3 = "": op4 = ""
If stringsize > 0 Then
    X = 1: Y = 0
    While (X <= stringsize) And (Mid(asmline, X, 1) <> ";")
        X = X + 1
    Wend
    progline = Left(asmline, X)
    stringsize = X
    X = 1
    For z = 0 To 22
        While (Mid(asmline, X, 1) = " " Or Mid(asmline, X, 1) = "," Or Mid(asmline, X, 1) = vbTab) And (X <= stringsize) '
            X = X + 1
        Wend
        Y = X
        While (X <= stringsize) And ((Mid(asmline, X, 1) <> " " And Mid(asmline, X, 1) <> "," And Mid(asmline, X, 1) <> vbTab)) '
            X = X + 1
        Wend
        If X > stringsize Then X = stringsize
        op(z) = Mid(asmline, Y, X - Y)
    Next z
    op1 = op(0): op2 = op(1): op3 = op(2): op4 = op(3)
End If
End Sub

Public Sub checklabel(ByVal st As String)
Dim X As Integer
st = LCase(st)
If pass = 1 Then
    newlabel = ""
    If Right(st, 1) = ":" Then
        st = Left(st, Len(st) - 1)
        For X = 1 To labelcounter
            If all_labels(X) = st Then
                message = "duplicate label -: " + st
                GoTo finish
            End If
        Next X
        goodinst = True
        labelcounter = labelcounter + 1
        all_labels(labelcounter) = st
        newlabel = st + ":"
        If address >= &H2100 Then
            labelvalue(labelcounter) = address - &H2100
        Else
            labelvalue(labelcounter) = address
        End If
finish:
    op1 = op2: op2 = op3: op3 = op4: op4 = ""
    End If
End If
End Sub

Public Sub checkopcode(ByVal st As String)
Dim X As Integer

opcode = ""
st = LCase(st)
For X = 0 To 21
    If ops_byte(X) = st Then
        basecode = byte_val(X)
        opcode = "byte_val"
        goodinst = True
        Exit Sub
    End If
Next X
For X = 0 To 3
    If ops_bit(X) = st Then
        basecode = bit_val(X)
        opcode = "bit_val"
        goodinst = True
        Exit Sub
    End If
Next X
For X = 0 To 7
    If ops_lit(X) = st Then
        basecode = lit_val(X)
        opcode = "lit_val"
        goodinst = True
        Exit Sub
    End If
Next X
For X = 0 To 7
    If ops_cont(X) = st Then
    basecode = cont_val(X)
    opcode = "cont_val"
    goodinst = True
    Exit Sub
End If
Next X
For X = 0 To 5
    If ops_inherent(X) = st Then
    basecode = inherent_val(X)
    opcode = "inherent_val"
    goodinst = True
    Exit Sub
End If
Next X
For X = 0 To 2
    If ops_c_comp(X) = st Then
    basecode = c_comp_val(X)
    opcode = "c_comp_val"
    goodinst = True
    Exit Sub
End If
Next X
End Sub



Public Sub setconstant()

End Sub

Private Sub setvariable(ByVal st As String)
Dim X As Integer
st = LCase(st)
For X = 1 To varicounter
    If variables(X) = st Then
        message = "Duplicate variable name"
        Exit Sub
    End If
Next X
    varicounter = varicounter + 1
    variables(varicounter) = st
    variablevalue(varicounter) = hexbyte

End Sub


Private Sub formbyte(ByVal st As String)
Dim X, Y, z As Integer

hexbyte = 0
st = LCase(st)
For X = 1 To Len(st)
    Y = InStr("0123456789abcdef", Mid(st, X, 1))
    If Y <> 0 Then
        Y = Y - 1
        hexbyte = hexbyte Or (Y)
        If X < Len(st) Then hexbyte = hexbyte * 16
    Else: message = "Invalid hex character"
    End If
Next X
End Sub


Private Sub format(ByVal st As String)
Dim X, mult As Integer
message = ""
If (Left(st, 2) = "h'") Or (Left(st, 2) = "H'") Then
    st = Mid(st, 3, Len(st))
    If Right(st, 1) <> "'" Then
        message = "Invalid Hex format"
        Exit Sub
    End If
    st = Left(st, Len(st) - 1)
    If Len(st) = 0 Or Len(st) > 4 Then
        message = "Invalid hex data length"
        Exit Sub
    End If
    formbyte (st)
    Exit Sub
End If
If (Left(st, 2) = "b'") Or (Left(st, 2) = "B'") Then
    st = Mid(st, 3, Len(st))
    If Right(st, 1) <> "'" Then
        message = "Invalid binary format"
        Exit Sub
    End If
    st = Left(st, Len(st) - 1)
    If Len(st) = 0 Or Len(st) > 8 Then
        message = "Invalid Binary length"
        Exit Sub
    End If
    For X = 1 To Len(st)
        If (Mid(st, X, 1) <> "0" And Mid(st, X, 1) <> "1") Then
            message = "Not a binary digit:"
            Exit Sub
        End If
    Next X
    hexbyte = 0: mult = 1
    For X = Len(st) To 1 Step -1
        If Mid(st, X, 1) = "1" Then hexbyte = hexbyte + mult
        mult = mult * 2
    Next X
    Exit Sub
End If
test = Left(st, 1)
If Left(st, 1) = """" Then
    st = Mid(st, 2, Len(st))
    If Right(st, 1) <> """" Then
        message = "Must be a single character"
        Exit Sub
    End If
    hexbyte = Asc(st)
    Exit Sub
End If
For X = 1 To Len(st)
    If Mid(st, X, 1) < "0" Or Mid(st, X, 1) > "9" Then
        message = "Not a numeric value"
        Exit Sub
    End If
Next X
hexbyte = Val(st)
End Sub


Private Sub seteeprom()
Dim X As Integer
Dim textmode, good_byte As Boolean
Dim char, eep_byte As String

    textmode = False

If address < &H2100 Then
    message = "Not an eeprom address"
    Exit Sub
End If
If pass = 1 Then
    eep_byte = ""
    progline = (Mid(progline, InStr(progline, "de") + 3, Len(progline)))
   For X = 1 To Len(progline)
    valid = False: good_byte = False
    
    char = Mid(progline, X, 1)
    
    If char = """" Then
        If textmode Then
            textmode = False
        Else
            textmode = True
        End If
    End If
    
    If (Not textmode) And (char <> """") And (char <> " ") And (char <> vbTab) And (char <> ",") And (char <> ";") Then
       eep_byte = eep_byte + char
    End If
    
    If (char = ",") Or (X = Len(progline)) Then good_byte = True
    
    
    If (Not good_byte) And (textmode) And (char <> """") Then
        eep_byte = char
        eep_byte = """" + eep_byte + """"
        good_byte = True
    End If
   
    If (good_byte) And (eep_byte <> "") Then
        format (eep_byte)
    
        If message <> "" Then Exit Sub
        If (hexbyte > 255) Or (hexbyte > maxrom) Then
            message = "Rom data too big"
            Exit Sub
        End If
        romloc = address - &H2100
        romdata(romloc) = hexbyte
        address = address + 1
        eep_byte = ""
    End If
    Next X

End If

End Sub

Private Sub setaddress(ByVal st As String)
format (st)
address = hexbyte
End Sub



Private Sub getaddress()
If pass = 2 Then
    hexline = heks(address * 2) + "00"
    csum = high(address * 2) + low(address * 2)
End If
End Sub


Private Function checkvar(ByVal st As String)
Dim X As Integer

valid = False
For X = 1 To varicounter
    If LCase(variables(X)) = LCase(st) Then
        hexbyte = variablevalue(X)
        valid = True
        Exit Function
    End If
Next X

End Function


Private Sub findlabel(ByVal st As String)
Dim X As Integer
st = LCase(st)
valid = False
For X = 1 To labelcounter
    If all_labels(X) = st Then
        hexbyte = labelvalue(X)
        valid = True
        Exit Sub
    End If
Next X
End Sub


Private Sub byte_ops()

'd = 1
If (LCase(op1) <> "clrw") Then
    If (LCase(op1) <> "clrf") And (LCase(op1) <> "movwf") Then
        If Left(op3, 1) = "," Then op3 = Mid(op3, 2, Len(op3))
        If Len(op3) <> 1 Then
            message = "Invalid direction indicator"
            Exit Sub
        End If
        If (InStr("0,1,w,f,W,F", op3) = 0) And (op3 <> "") Then
            message = "Invalid direction indicator"
            Exit Sub
        End If
    End If
If InStr("0wW", Left(op3, 1)) <> 0 Then d = 0
If (LCase(op1) = "clrf") Or (LCase(op1) = "movwf") Then d = 1
checkvar (op2)
If Not valid Then format (op2)
If d = 0 Then basecode = basecode And 65280
If d = 1 Then basecode = basecode Or &H80
basecode = basecode Or (hexbyte And &H7F)
End If
End Sub


Private Sub bit_ops()
Dim X As Integer
message = ""
checkvar (op2)  'get operand
If Not valid Then format (op2)
basecode = basecode Or (hexbyte And &H7F)
If message <> "" Then Exit Sub
checkvar (op3)
If (Not valid) Then format (op3)
If (message = "") And (InStr("01234567", hexbyte)) Then basecode = basecode Or (hexbyte * 128)
End Sub



Private Sub lit_ops()
If Not (InStr("clrwdt retfie return sleep", LCase(op1))) Then
    If (LCase(op1) = "movlw") And (LCase(op2) = "high") Then
        findlabel (op3)
        hexbyte = high(hexbyte)
        basecode = basecode Or hexbyte
        Exit Sub
    End If
    If (LCase(op1) = "movlw") And (LCase(op2) = "low") Then
        findlabel (op3)
        hexbyte = low(hexbyte)
        basecode = basecode Or hexbyte
        Exit Sub
    End If
    If (LCase(op1) = "goto") And (Left(op2, 1) = "$") Then
        If Len(op2) < 3 Then
            message = "Invalid offset value"
            Exit Sub
        End If
        If (Mid(op2, 2, 1) <> "+") And (Mid(op2, 2, 1) <> "-") Then
            message = "Invalid direction indicator"
            Exit Sub
        End If
        format (Mid(op2, 3, Len(op2) - 2))
        If Mid(op2, 2, 1) = "+" Then
            basecode = basecode Or (address + hexbyte)
        Else
            basecode = basecode Or (address - hexbyte)
        End If
        Exit Sub
    End If
    
    checkvar (op2)
    If Not valid Then findlabel (op2)
    If Not valid Then format (op2)
    basecode = basecode Or hexbyte
End If
End Sub
Private Sub cont_ops()

End Sub
Private Sub inherent_ops()

End Sub
Private Sub c_comp_ops()

End Sub
Private Sub outline()
Dim X As Integer
Dim st As String
Dim csumbyte As Byte

If pass = 2 Then
    st = Mid(heks(bytecount * 2), 3, 2)
    csum = csum + (bytecount * 2)
    hexline = ":" + st + hexline
    For X = 1 To bytecount
        csum = csum + high(hexdata(X)) + low(hexdata(X))
        hexline = hexline + heks(hexdata(X))
    Next X
    csumbyte = low((Not csum) + 1)
    hexline = hexline + Mid(heks(csumbyte), 3, 2)
    Print #(hexdatafilenum), hexline
    bytecount = 0
    For X = 1 To 8
        hexdata(X) = 0
    Next X
    getaddress
End If
End Sub



Public Sub assemble()
On Error GoTo procerror

Dim X As Integer
For X = 1 To 200
    all_labels(X) = ""
Next X
labelcounter = 1
configword = &H3FFF
config = &H3FFF
ramloc = ramstart
pass = 1
For X = 1 To 8
    hexdata(X) = &HFF
Next X
For X = 0 To 512
    romdata(X) = &HFF
Next X
mode = 0

Check1.Visible = False
Check2.Visible = False
Check3.Visible = False
Check4.Visible = False
Check5.Visible = False
Check6.Visible = False
Check7.Visible = False
Check8.Visible = False
Check9.Visible = False
Check10.Visible = False


   
If (filename = "") Or (filename = "No File Selected") Or Right(filename, 4) <> ".asm" Then
    answer = MsgBox("Bad File or no file" + vbCrLf + "Selected", 48, "pic assembler")
    Exit Sub
End If

ops_byte = Array("addwf", "addwfc", "andwf", "asrf", "lslf", "lsrf", "clrf", "clrw", "comf", "decf", "incf", "iorwf", "movf", "movwf", "rlf", "rrf", "subwf", "subwfb", "swapf", "xorwf", "decfsz", "incfsz")
byte_val = Array(&H700, &H3D00, &H500, &H3700, &H3500, &H3600, &H180, &H100, &H900, &H300, &HA00, &H400, &H800, &H80, &HD00, &HC00, &H200, &H3B00, &HE00, &H600, &HB00, &HF00)

ops_bit = Array("bcf", "bsf", "btfsc", "btfss")
bit_val = Array(&H1000, &H1400, &H1800, &H1C00)

ops_lit = Array("addlw", "andlw", "iorlw", "movlb", "movlp", "movlw", "sublw", "xorlw")
lit_val = Array(&H3E00, &H3900, &H3800, &H20, &H3180, &H3000, &H3C00, &H3A00)

ops_cont = Array("bra", "brw", "call", "callw", "goto", "retfie", "retlw", "return")
cont_val = Array(&H3200, &HB, &H2000, &HA, &H2800, &H9, &H3400, &H8)

ops_inherent = Array("clrwdt", "nop", "option", "reset", "sleep", "tris")
inherent_val = Array(&H64, &H0, &H62, &H1, &H63, &H60)

ops_c_comp = Array("addfsr", "moviw", "movwi")
c_comp_val = Array(&H3100, &H10, &H3F00, &H18, &H3F80)

maxrom = 255

anyerrors = False
keydat = " "
labelcounter = 1
varicounter = 1
headerfile = False
address = 0
bytecount = 0
hexline = "000000"
csum = 0
ch = Asc(0)
mainfile = mypath + pickfile
Open mainfile For Input As mainfilenum
incfile = App.Path + "\datafiles\" + Combo2.Text + ".inc"
Open incfile For Input As incfilenum
outfile = mypath + stripfile + ".err"
Open outfile For Output As outfilenum
hexdatafile = mypath + stripfile + ".hex"
Open hexdatafile For Output As hexdatafilenum
While 1 = 1
    message = ""
    hexbyte = 0
    If Not (headerfile) Then Line Input #(mainfilenum), progline
    If (headerfile) Then Line Input #(incfilenum), progline
    parse (progline)
    newlabel = ""
    hexword = ""
    opcode = ""
    basecode = 0
    If Right((op1), 1) = ":" Then goodinst = True
    If pass = 1 Then checklabel (op1)
    If LCase(op1) = "set" Then goodinst = True
    If LCase(op1) = "__config" Then goodinst = True
    If LCase(op1) = "list" Then goodinst = True
    If LCase(op1) = "#include" Then goodinst = True
    If LCase(op1) = "de" Then goodinst = True
    If LCase(op1) = "org" Then goodinst = True
    If LCase(op2) = "res" Then goodinst = True
    If LCase(op2) = "equ" Then goodinst = True
    If op1 = "" Then goodinst = True
    If LCase(op1) = "end" Then goodinst = True
    If message <> "" Then GoTo disperror
    If Len(op1) <> 0 Then
        If (LCase(op1) = "end") And (pass = 2) Then GoTo terminate
        If (LCase(op1) = "end") And (pass = 1) Then
            op1 = ""
            Close #(mainfilenum)
            Open mainfile For Input As mainfilenum
            headerfile = False
            pass = 2
            address = 0
        End If
        If (LCase(op1) = "#include") And (pass = 1) And (Not headerfile) Then
            headerfile = True
            Close #(incfilenum)
            incfile = App.Path + "\datafiles\" + op2
            Open incfile For Input As incfilenum
        End If
        If (headerfile) And (EOF(incfilenum)) Then headerfile = False
        If LCase(op1) = "de" Then seteeprom
        If LCase(op1) = "org" Then
            outline
            setaddress (op2)
            getaddress
        End If
        If (LCase(op2) = "equ") And (pass = 1) Then
            format (op3)
            setvariable (op1)
        End If
        If (LCase(op1) = "list") And (pass = 1) Then setfunction (1)
        If (LCase(op1) = "__config" And (pass = 1)) Then setconfig
        If pass = 1 Then
            If LCase(op2) = "res" Then
                hexbyte = ramloc
                ramloc = ramloc + 1
                setvariable (op1)
            End If
        End If
    End If
    If (Right(op1, 1) = ":") And (op2 <> "") Then
        newlabel = op1
        op1 = op2
        op2 = op3
        op3 = op4
        op4 = ""
    End If
    checkopcode (op1)
    If pass = 2 Then
        If opcode = "byte_val" Then byte_ops
        If opcode = "bit_val" Then bit_ops
        If opcode = "lit_val" Then lit_ops
        If opcode = "cont_val" Then cont_ops
        If opcode = "inherent_val" Then inherent_ops
        If opcode = "c_comp_val" Then c_comp_ops
    End If
    If Not goodinst Then message = "Invalid instruction"
disperror:
    If message <> "" Then
        If newlabel <> "" Then Print #(outfilenum), heks(address) + " " + newlabel
        hexword = heks(basecode)
        If basecode = 0 Then hexword = ""
        Print #(outfilenum), heks(address) + " " + op1 + " " + op2 + " " + op3 + " " + hexword + " " + message
        anyerrors = True
    End If
    If opcode <> "" Then address = address + 1
    If (bytecount <= 8) And (Not EOF(mainfilenum)) And (pass = 2) Then
        If opcode <> "" Then
            hexdata(bytecount + 1) = swap(basecode)
            bytecount = bytecount + 1
        End If
    End If
    If bytecount = 8 Then outline
Wend
terminate:
    outline
    csum = low(config) + high(config) + 80
    csum = ((Not csum) + 1) And 255
    Print #(hexdatafilenum), ":084000000f000f000f000f007c"
    Print #(hexdatafilenum), ":02400e00" + heks(swap(config)) + Mid(heks(csum), 3, 2)
    address = &H2100
    getaddress
    If romloc = 0 Then GoTo norom
    bytecount = 0
    For X = 0 To maxrom
        hexdata(bytecount + 1) = swap(romdata(X))
        bytecount = bytecount + 1
        address = address + 1
        If bytecount = 8 Then outline
    Next X
    If bytecount > 0 Then outline
norom:
    Print #(hexdatafilenum), ":00000001ff"
    
    Close #(outfilenum)
    Close #(mainfilenum)
    Close #(incfilenum)
    Close #(hexdatafilenum)
    If Not anyerrors Then
    
    End If

    If anyerrors Then
       Close #(outfilenum)
        Open outfile For Input As outfilenum
        While Not EOF(outfilenum)
            Line Input #(outfilenum), st
            Print st
        Wend
        Close #(outfilenum)
    End If
Print "Assembly complete"
Exit Sub
procerror:
answer = MsgBox("Assembly aborted", 0, "")

End Sub
'swap high and low bytes  of a two byte word - result as long integer
Private Function swap(ByVal b As Long) As Long
Dim X, Y As Long
X = Int(b / 256) And &HFF
Y = (b And &HFF)
swap = ((Y * 256) Or X)
End Function



Private Function high(ByVal b As Long) As Long
high = Int(b / 256) And &HFF
End Function

Private Function low(ByVal b As Long) As Long
low = (b And &HFF)
End Function


Public Function heks(ByVal w As Long) As String
Dim N(4) As Byte
Dim X As Integer
Dim hexchar
hexchar = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f")
For X = 1 To 4
    N(X) = w And 15
    w = Int(w / 16)
Next X
heks = hexchar(N(4)) + hexchar(N(3)) + hexchar(N(2)) + hexchar(N(1))

End Function




Public Sub outcommand(ByVal command As Byte)
Dim X As Integer
While MSComm1.CTSHolding = False
Wend
MSComm1.Output = Chr(command)
End Sub

Public Sub outdata(ByVal data As Long)
Dim X, lo, hi As Byte
hi = low(data) And &HFF
lo = high(data) And &HFF

While MSComm1.CTSHolding = False
Wend
MSComm1.Output = Chr(lo)

While MSComm1.CTSHolding = False
Wend
MSComm1.Output = Chr(hi)
 
End Sub

Public Function indata() As Long
Dim X, inbuffer, Y

While X < 2
X = MSComm1.InBufferCount
Wend
inbuffer = MSComm1.Input
 low_byte = CByte(inbuffer(0))
   

    high_byte = CByte(inbuffer(1))
    valid_byte = True

Y = (high_byte * 256) Or (low_byte)
indata = swap(Y)
End Function

Public Sub setprogmode()
While MSComm1.CTSHolding = False
Wend
MSComm1.Output = Chr(&HC0)    'the interface code for set programme entry mode
End Sub

Public Sub erasepic()

Dim X, Y As Long
 Dim ch As String
 
 
 setprogmode
 
 If mode = 2 Then
  outcommand (0): outdata (&HFF3F)
  delay (20)
  outcommand (&H1F)
  delay (20)
 End If
 If mode = 1 Then
 
  outcommand (0) '{load config word}
  outdata 0
  outcommand 9
  delay 20
  outcommand 11
  delay 20
  setprogmode
  
  outcommand 0
  X = &HFF3F
  outdata (X)
  
  For Y = 1 To 7    'inc address
    outcommand (6)
  Next Y
  outcommand (1)
  outcommand (7)
  outcommand (8)
  delay (20)
  outcommand (1)
  outcommand (7)
  outcommand 3 '(cmdloaddatamem)/////
  outdata &HFF3F
  outcommand 11 '(cmdbulkeraseeprom)
  delay 20
  outcommand 2: outdata &HFF3F
  outcommand 9
  outcommand (&H18)
 delay 20
 End If

 End Sub



Public Sub readhexfile()
On Error GoTo procerror
Dim hexline As String
Dim dataout, mode, bytecount, picaddress As Long
 Dim X, Y, z As Long


 If (filename = "") Or (filename = "No File Selected") Then

  GoTo procerror
End If

 For X = 0 To himem
    memdata(X) = &HFF3F
 Next X
 For X = 0 To maxrom
    epdata(X) = &HFF00
 Next X
 picaddress = 0
 Open hexdatafile For Input As #(hexdatafilenum)
 
 While Not EOF(hexdatafilenum)
  Line Input #(hexdatafilenum), hexline
  formbyte (Mid(hexline, 2, 2)): bytecount = hexbyte * 2
  formbyte (Mid(hexline, 4, 4)): picaddress = Int(hexbyte / 2)
  formbyte (Mid(hexline, 8, 2)): mode = hexbyte
  formbyte (Mid(hexline, Len(hexline) - 1, 2)): csum = hexbyte

  hexline = Mid(hexline, 10, (Len(hexline) - 11))
  If picaddress < himem Then
  
   X = 0: Y = 0
   If Len(hexline) > 0 Then
    Do Until X >= bytecount
     formbyte (Mid(hexline, X + 1, 4)): memdata(picaddress + Y) = hexbyte
     X = X + 4: Y = Y + 1
    Loop
   End If
  End If
  If picaddress = &H2000 Then   '          {get device id}
  
   X = 0: Y = 0
   If Len(hexline) > 0 Then
    Do Until X >= bytecount
     formbyte (Mid(hexline, X + 1, 4)) ':  deviceid(picaddress + y) = hexbyte
     X = X + 4: Y = Y + 1
    Loop
  End If
  End If
  If picaddress = &H2007 Then  '            {get config word}
  
   formbyte (Mid(hexline, 1, 4)): configword = hexbyte
  End If

  If (picaddress > &H20FF) Then   '         {get eeprom data}
  
   X = 0: Y = 0
    If Len(hexline) > 0 Then
        Do Until X >= bytecount
         formbyte (Mid(hexline, X + 1, 4)): epdata(picaddress - &H2100 + Y) = hexbyte
         X = X + 4: Y = Y + 1
        Loop
    End If
  End If
 Wend
Close #(hexdatafilenum)
Exit Sub
procerror:
answer = MsgBox("Read Hexfile aborted", 0, "")
 End Sub

Public Function bintoword(ByVal st As String) As Long
Dim X, binword, temp As Long
 temp = 0: binword = 1
 For X = 14 To 1 Step -1
   If Mid(st, X, 1) = "1" Then temp = temp + binword
    binword = binword * 2
 Next X
bintoword = temp
End Function


Public Sub progconfig()

Dim X, Y, z As Long
Dim st As String
Cls
 Print "Programming Configuration Memory"
 setprogmode
 outcommand (cmdloadconfig)
 outdata (configword)
 For X = 1 To 7
  
   outcommand (cmdincaddress)
 Next X

 outcommand (cmdloaddatamem)
 outdata (configword)
 If mode = 2 Then
  
   outcommand (&H18) ';{prog only}

   outcommand (&H17) ';{end prog}
 
   outcommand (&H6)  ';{inc addr}

   outcommand (&H2) ';{load data}
   outdata (&HFF3F)
  
   outcommand (&H18) ';{prog only}

  
   outcommand (&H17) ';{end prog}
 Else
   
    outcommand 8 '(cmdbegineraseprog)
 End If

 setprogmode

 outcommand (cmdloadconfig): outdata (&HFF3F)
 For X = 1 To 7
  
    outcommand (cmdincaddress)
 Next X
 
   outcommand 4 '(cmdreaddatamem)
   z = swap(indata)
   Print "Config word sent to pic " + Hex(swap(configword)), ' ')
   Print
   Print "Config word read " + Hex(z)

End Sub


Public Sub calcconfig()
On Error GoTo procerror
Dim X, bitvalue, mask, cfw As Integer
cfw = swap(configword)

X = 0
For X = 1 To 10
Select Case X

Case 1
    Check1.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check1.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check1.Value = 1
    
Case 2
    Check2.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check2.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check2.Value = 1
    
Case 3
    Check3.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check3.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check3.Value = 1
    
Case 4
    Check4.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check4.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check4.Value = 1
    
Case 5
    Check5.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check5.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check5.Value = 1
    
Case 6
    Check6.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check6.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check6.Value = 1
    
Case 7
    Check7.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check7.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check7.Value = 1
    
Case 8
    Check8.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check8.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check8.Value = 1
    
Case 9
    Check9.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check9.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check9.Value = 1
    
Case 10
    Check10.Value = 0
    bitvalue = (cfg(X).valueon Xor cfg(X).valueoff)
    mask = cfw And bitvalue
    If (mask = bitvalue) And ((cfg(X).valueoff Xor &H3FFF) = bitvalue) Then Check10.Value = 1
    If (mask <> bitvalue) And ((cfg(X).valueon Xor &H3FFF) = bitvalue) Then Check10.Value = 1
    
End Select
Next X
mask = ((cfw) And oscmask) Xor oscmask
  For X = 1 To 8
     bitvalue = (osc(X).valueon Xor &H3FFF)
        If (mask = bitvalue) Then
            Combo1.Text = osc(X).name
            Exit For
        End If
 Next X
 Exit Sub
procerror:
 answer = MsgBox("Calc config aborted", 0, "")

End Sub

Private Sub datin() 'MSComm1_OnComm()
Dim inbuffer
Dim X
valid_byte = False
 
While MSComm1.CTSHolding = False
Wend
MSComm1.Output = Chr(32)
While MSComm1.CTSHolding = False
Wend
MSComm1.Output = Chr(1)



While X < 2
X = MSComm1.InBufferCount
Wend
inbuffer = MSComm1.Input
 low_byte = CByte(inbuffer(0))
   

    high_byte = CByte(inbuffer(1))
    valid_byte = True

bitcount = bitcount + 1

End Sub




Private Sub Option1_Click()
file1.Pattern = "*.asm"
End Sub

Private Sub Option2_Click()
file1.Pattern = "*.hex"
End Sub

Private Sub Option3_Click()
file1.Pattern = "*.err"
End Sub


Public Sub vppoff()
While MSComm1.CTSHolding = False
Wend
MSComm1.Output = Chr(&H80)

End Sub

Public Sub vppon()
Dim success As Byte
success = False
Do While success = False
success = (EscapeCommFunction(COMmNum, 8))
Loop
End Sub

Public Sub delay(delayvalue As Long)
Dim t1 As Long
t1 = GetTickCount
Do While (GetTickCount - t1) < delayvalue
Loop
End Sub


Private Sub Option4_Click()
file1.Pattern = "*.*"
End Sub

